home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / Src / Ch3 / PalWatch.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1999-04-01  |  8.0 KB  |  238 lines
  1. VERSION 5.00
  2. Begin VB.Form PalWatchForm 
  3.    Caption         =   "PalWatch"
  4.    ClientHeight    =   2460
  5.    ClientLeft      =   6810
  6.    ClientTop       =   975
  7.    ClientWidth     =   2460
  8.    LinkTopic       =   "Form1"
  9.    PaletteMode     =   1  'UseZOrder
  10.    ScaleHeight     =   164
  11.    ScaleMode       =   3  'Pixel
  12.    ScaleWidth      =   164
  13.    Begin VB.Timer ColorTimer 
  14.       Interval        =   1000
  15.       Left            =   600
  16.       Top             =   120
  17.    End
  18.    Begin VB.PictureBox picCanvas 
  19.       AutoRedraw      =   -1  'True
  20.       AutoSize        =   -1  'True
  21.       Height          =   300
  22.       Left            =   0
  23.       Picture         =   "PalWatch.frx":0000
  24.       ScaleHeight     =   16
  25.       ScaleMode       =   3  'Pixel
  26.       ScaleWidth      =   16
  27.       TabIndex        =   0
  28.       Top             =   0
  29.       Width           =   300
  30.    End
  31.    Begin VB.Menu mnuColor 
  32.       Caption         =   "(0, 0, 0)"
  33.       NegotiatePosition=   3  'Right
  34.    End
  35. Attribute VB_Name = "PalWatchForm"
  36. Attribute VB_GlobalNameSpace = False
  37. Attribute VB_Creatable = False
  38. Attribute VB_PredeclaredId = True
  39. Attribute VB_Exposed = False
  40. Option Explicit
  41. Private Type PALETTEENTRY
  42.     peRed As Byte
  43.     peGreen As Byte
  44.     peBlue As Byte
  45.     peFlags As Byte
  46. End Type
  47. Private Const PC_EXPLICIT = &H2
  48. Private Const RASTERCAPS = 38
  49. Private Const RC_PALETTE = &H100
  50. Private Const NUMRESERVED = 106
  51. Private Const SIZEPALETTE = 104
  52. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
  53. Private Declare Function ResizePalette Lib "gdi32" (ByVal hPalette As Long, ByVal nNumEntries As Long) As Long
  54. Private Declare Function SetPaletteEntries Lib "gdi32" (ByVal hPalette As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
  55. Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
  56. Private Const PALETTE_INDEX = &H1000000
  57. Private Const NO_COLOR = -1
  58. Private LogicalPalette As Long
  59. Private SysPalSize As Integer
  60. Private NumStaticColors As Integer
  61. Private SelectedI As Integer
  62. Private SelectedJ As Integer
  63. Private SelectedColor As Integer
  64. Private SelectedR As Integer
  65. Private SelectedG As Integer
  66. Private SelectedB As Integer
  67. Private dx As Integer
  68. Private dy As Integer
  69. ' Load the Pict palette with PC_EXPLICIT entries
  70. ' so they match the system palette.
  71. Private Sub LoadSystemPalette()
  72. Dim palentry(0 To 255) As PALETTEENTRY
  73. Dim i As Integer
  74.     ' Make the logical palette as big as possible.
  75.     LogicalPalette = picCanvas.Picture.hPal
  76.     If ResizePalette(LogicalPalette, SysPalSize) = 0 Then
  77.         MsgBox "Error resizing the palette."
  78.         End
  79.     End If
  80.     ' Flag all palette entries as PC_EXPLICIT.
  81.     ' Set peRed to the system palette indexes.
  82.     For i = 0 To SysPalSize - 1
  83.         palentry(i).peRed = i
  84.         palentry(i).peFlags = PC_EXPLICIT
  85.     Next i
  86.     ' Update the palette (ignore return value).
  87.     i = SetPaletteEntries(LogicalPalette, 0, SysPalSize, palentry(0))
  88. End Sub
  89. ' Fill the system picture with all the palette
  90. ' colors, hatching the static colors.
  91. Private Sub ShowColors()
  92. Dim i As Integer
  93. Dim j As Integer
  94. Dim clr As Integer
  95. Dim oldfill As Integer
  96. Dim olddraw As Integer
  97.     picCanvas.Cls
  98.     ' Display the colors using palette indexing.
  99.     dx = picCanvas.ScaleWidth / 16
  100.     dy = picCanvas.ScaleHeight / 16
  101.     clr = 0
  102.     For i = 0 To 15
  103.         For j = 0 To 15
  104.             picCanvas.Line (j * dx, i * dy)-Step(dx, dy), _
  105.                 clr + PALETTE_INDEX, BF
  106.             clr = clr + 1
  107.         Next j
  108.     Next i
  109.     ' Hatch the static colors.
  110.     oldfill = picCanvas.FillStyle
  111.     olddraw = picCanvas.DrawMode
  112.     picCanvas.FillStyle = vbDownwardDiagonal
  113.     picCanvas.DrawMode = vbInvisible
  114.     picCanvas.Line (0, 0)-Step((NumStaticColors \ 2) * dx - 1, dy - 1), , B
  115.     picCanvas.Line (j * dx, i * dy)-Step(-(NumStaticColors \ 2) * dx, -dy), , B
  116.     picCanvas.FillStyle = oldfill
  117.     picCanvas.DrawMode = olddraw
  118.     ' Highlight the previously selected color.
  119.     SelectedColor = NO_COLOR
  120.     SelectColor SelectedI, SelectedJ
  121. End Sub
  122. ' Select the color at the indicated position.
  123. Private Sub SelectColor(ByVal i As Integer, ByVal j As Integer)
  124. Const GAP1 = 1
  125. Const GAP2 = 2
  126. Const DRAW_WID = 2
  127. Dim oldmode As Integer
  128. Dim oldwid As Integer
  129.     oldmode = picCanvas.DrawMode
  130.     oldwid = picCanvas.DrawWidth
  131.     picCanvas.DrawMode = vbInvert
  132.     picCanvas.DrawWidth = DRAW_WID
  133.     ' Unhighlight the previously selected color.
  134.     If SelectedColor <> NO_COLOR Then _
  135.         picCanvas.Line (SelectedJ * dx + GAP1, SelectedI * dx + GAP1)-Step(dx - GAP2, dx - GAP2), , B
  136.     ' Record the new color.
  137.     SelectedI = i
  138.     SelectedJ = j
  139.     SelectedColor = i * 16 + j
  140.     ' Highlight the new color.
  141.     picCanvas.Line (SelectedJ * dx + GAP1, SelectedI * dx + GAP1)-Step(dx - GAP2, dx - GAP2), , B
  142.     picCanvas.DrawMode = oldmode
  143.     picCanvas.DrawWidth = oldwid
  144.     ' Display the color's components in mnuColor.
  145.     ShowColorValue
  146. End Sub
  147. ' If the selected color's components have
  148. ' changed, display the new values in mnuColor.
  149. Private Sub ShowColorValue()
  150. Dim palentry As PALETTEENTRY
  151. Dim status As Integer
  152.     status = GetSystemPaletteEntries(picCanvas.hdc, SelectedColor, 1, palentry)
  153.     If palentry.peRed <> SelectedR Or _
  154.        palentry.peGreen <> SelectedG Or _
  155.        palentry.peBlue <> SelectedB Then
  156.             mnuColor.Caption = "(" & _
  157.                 Format$(palentry.peRed) & "," & _
  158.                 Str$(palentry.peGreen) & "," & _
  159.                 Str$(palentry.peBlue) & ")"
  160.     End If
  161. End Sub
  162. ' Make sure the selected color's components are up to date.
  163. Private Sub ColorTimer_Timer()
  164.     ShowColorValue
  165. End Sub
  166. ' Get basic palette information.
  167. Private Sub Form_Load()
  168.     ' Make sure the screen supports palettes.
  169.     If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
  170.         MsgBox "This system is not using palettes."
  171.         End
  172.     End If
  173.     ' See how big the system palette is.
  174.     SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
  175.     ' See how many colors are reserved.
  176.     NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
  177.     ' Load the system palette.
  178.     LoadSystemPalette
  179. End Sub
  180. ' Make the picture as large as possible.
  181. Private Sub Form_Resize()
  182. Dim wid As Single
  183. Dim hgt As Single
  184.     If WindowState = vbMinimized Then Exit Sub
  185.     wid = ScaleWidth - 2 * picCanvas.Left
  186.     If wid < 10 Then wid = 10
  187.     hgt = ScaleHeight - 2 * picCanvas.Top
  188.     If hgt < 10 Then hgt = 10
  189.     picCanvas.Move picCanvas.Left, picCanvas.Top, wid, hgt
  190.     ' Display the colors.
  191.     ShowColors
  192. End Sub
  193. ' Select the color the user clicked on.
  194. Private Sub picCanvas_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  195. Dim i As Integer
  196. Dim j As Integer
  197.     i = Y \ dx
  198.     j = X \ dy
  199.     SelectColor i, j
  200. End Sub
  201. ' Allow the user to select a new color with the
  202. ' arrow keys.
  203. Private Sub picCanvas_KeyDown(KeyCode As Integer, Shift As Integer)
  204. Dim i As Integer
  205. Dim j As Integer
  206.     i = SelectedI
  207.     j = SelectedJ
  208.     Select Case KeyCode
  209.         Case vbKeyDown
  210.             i = i + 1
  211.             If i * 16 + j >= SysPalSize Then i = 0
  212.         
  213.         Case vbKeyUp
  214.             i = i - 1
  215.             If i < 0 Then
  216.                 i = (SysPalSize - 1) \ 16
  217.                 If i * 16 + j >= SysPalSize Then _
  218.                     i = i - 1
  219.             End If
  220.         
  221.         Case vbKeyLeft
  222.             j = j - 1
  223.             If j < 0 Then
  224.                 j = 15
  225.                 If i * 16 + j >= SysPalSize Then _
  226.                     j = SysPalSize - 1 - i * 16
  227.             End If
  228.         
  229.         Case vbKeyRight
  230.             j = j + 1
  231.             If j > 15 Or _
  232.                 i * 16 + j >= SysPalSize Then _
  233.                     j = 0
  234.         
  235.     End Select
  236.     SelectColor i, j
  237. End Sub
  238.